home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / gnus / nnbabyl.el.z / nnbabyl.el
Encoding:
Text File  |  1998-05-21  |  21.0 KB  |  651 lines
  1. ;;; nnbabyl.el --- rmail mbox access for Gnus
  2. ;; Copyright (C) 1995,96,97 Free Software Foundation, Inc.
  3.  
  4. ;; Author: Lars Magne Ingebrigtsen <larsi@ifi.uio.no>
  5. ;;     Masanobu UMEDA <umerin@flab.flab.fujitsu.junet>
  6. ;; Keywords: news, mail
  7.  
  8. ;; This file is part of GNU Emacs.
  9.  
  10. ;; GNU Emacs is free software; you can redistribute it and/or modify
  11. ;; it under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18. ;; GNU General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  22. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  23. ;; Boston, MA 02111-1307, USA.
  24.  
  25. ;;; Commentary:
  26.  
  27. ;; For an overview of what the interface functions do, please see the
  28. ;; Gnus sources.
  29.  
  30. ;;; Code:
  31.  
  32. (require 'nnheader)
  33. (require 'rmail)
  34. (require 'nnmail)
  35. (require 'nnoo)
  36. (eval-when-compile (require 'cl))
  37.  
  38. (nnoo-declare nnbabyl)
  39.  
  40. (defvoo nnbabyl-mbox-file (expand-file-name "~/RMAIL")
  41.   "The name of the rmail box file in the users home directory.")
  42.  
  43. (defvoo nnbabyl-active-file (expand-file-name "~/.rmail-active")
  44.   "The name of the active file for the rmail box.")
  45.  
  46. (defvoo nnbabyl-get-new-mail t
  47.   "If non-nil, nnbabyl will check the incoming mail file and split the mail.")
  48.  
  49. (defvoo nnbabyl-prepare-save-mail-hook nil
  50.   "Hook run narrowed to an article before saving.")
  51.  
  52.  
  53.  
  54. (defvar nnbabyl-mail-delimiter "\^_")
  55.  
  56. (defconst nnbabyl-version "nnbabyl 1.0"
  57.   "nnbabyl version.")
  58.  
  59. (defvoo nnbabyl-mbox-buffer nil)
  60. (defvoo nnbabyl-current-group nil)
  61. (defvoo nnbabyl-status-string "")
  62. (defvoo nnbabyl-group-alist nil)
  63. (defvoo nnbabyl-active-timestamp nil)
  64.  
  65. (defvoo nnbabyl-previous-buffer-mode nil)
  66.  
  67. (eval-and-compile
  68.   (autoload 'gnus-set-text-properties "gnus-ems"))
  69.  
  70.  
  71.  
  72. ;;; Interface functions
  73.  
  74. (nnoo-define-basics nnbabyl)
  75.  
  76. (deffoo nnbabyl-retrieve-headers (articles &optional group server fetch-old)
  77.   (save-excursion
  78.     (set-buffer nntp-server-buffer)
  79.     (erase-buffer)
  80.     (let ((number (length articles))
  81.       (count 0)
  82.       (delim (concat "^" nnbabyl-mail-delimiter))
  83.       article art-string start stop)
  84.       (nnbabyl-possibly-change-newsgroup group server)
  85.       (while (setq article (pop articles))
  86.     (setq art-string (nnbabyl-article-string article))
  87.     (set-buffer nnbabyl-mbox-buffer)
  88.     (end-of-line)
  89.     (when (or (search-forward art-string nil t)
  90.           (search-backward art-string nil t))
  91.       (unless (re-search-backward delim nil t)
  92.         (goto-char (point-min)))
  93.       (while (and (not (looking-at ".+:"))
  94.               (zerop (forward-line 1))))
  95.       (setq start (point))
  96.       (search-forward "\n\n" nil t)
  97.       (setq stop (1- (point)))
  98.       (set-buffer nntp-server-buffer)
  99.       (insert "221 ")
  100.       (princ article (current-buffer))
  101.       (insert " Article retrieved.\n")
  102.       (insert-buffer-substring nnbabyl-mbox-buffer start stop)
  103.       (goto-char (point-max))
  104.       (insert ".\n"))
  105.     (and (numberp nnmail-large-newsgroup)
  106.          (> number nnmail-large-newsgroup)
  107.          (zerop (% (incf count) 20))
  108.          (nnheader-message 5 "nnbabyl: Receiving headers... %d%%"
  109.                    (/ (* count 100) number))))
  110.  
  111.       (and (numberp nnmail-large-newsgroup)
  112.        (> number nnmail-large-newsgroup)
  113.        (nnheader-message 5 "nnbabyl: Receiving headers...done"))
  114.  
  115.       (set-buffer nntp-server-buffer)
  116.       (nnheader-fold-continuation-lines)
  117.       'headers)))
  118.  
  119. (deffoo nnbabyl-open-server (server &optional defs)
  120.   (nnoo-change-server 'nnbabyl server defs)
  121.   (nnbabyl-create-mbox)
  122.   (cond
  123.    ((not (file-exists-p nnbabyl-mbox-file))
  124.     (nnbabyl-close-server)
  125.     (nnheader-report 'nnbabyl "No such file: %s" nnbabyl-mbox-file))
  126.    ((file-directory-p nnbabyl-mbox-file)
  127.     (nnbabyl-close-server)
  128.     (nnheader-report 'nnbabyl "Not a regular file: %s" nnbabyl-mbox-file))
  129.    (t
  130.     (nnheader-report 'nnbabyl "Opened server %s using mbox %s" server
  131.              nnbabyl-mbox-file)
  132.     t)))
  133.  
  134. (deffoo nnbabyl-close-server (&optional server)
  135.   ;; Restore buffer mode.
  136.   (when (and (nnbabyl-server-opened)
  137.          nnbabyl-previous-buffer-mode)
  138.     (save-excursion
  139.       (set-buffer nnbabyl-mbox-buffer)
  140.       (narrow-to-region
  141.        (caar nnbabyl-previous-buffer-mode)
  142.        (cdar nnbabyl-previous-buffer-mode))
  143.       (funcall (cdr nnbabyl-previous-buffer-mode))))
  144.   (nnoo-close-server 'nnbabyl server)
  145.   (setq nnbabyl-mbox-buffer nil)
  146.   t)
  147.  
  148. (deffoo nnbabyl-server-opened (&optional server)
  149.   (and (nnoo-current-server-p 'nnbabyl server)
  150.        nnbabyl-mbox-buffer
  151.        (buffer-name nnbabyl-mbox-buffer)
  152.        nntp-server-buffer
  153.        (buffer-name nntp-server-buffer)))
  154.  
  155. (deffoo nnbabyl-request-article (article &optional newsgroup server buffer)
  156.   (nnbabyl-possibly-change-newsgroup newsgroup server)
  157.   (save-excursion
  158.     (set-buffer nnbabyl-mbox-buffer)
  159.     (goto-char (point-min))
  160.     (when (search-forward (nnbabyl-article-string article) nil t)
  161.       (let (start stop summary-line)
  162.     (unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
  163.       (goto-char (point-min))
  164.       (end-of-line))
  165.     (while (and (not (looking-at ".+:"))
  166.             (zerop (forward-line 1))))
  167.     (setq start (point))
  168.     (or (when (re-search-forward
  169.            (concat "^" nnbabyl-mail-delimiter) nil t)
  170.           (beginning-of-line)
  171.           t)
  172.         (goto-char (point-max)))
  173.     (setq stop (point))
  174.     (let ((nntp-server-buffer (or buffer nntp-server-buffer)))
  175.       (set-buffer nntp-server-buffer)
  176.       (erase-buffer)
  177.       (insert-buffer-substring nnbabyl-mbox-buffer start stop)
  178.       (goto-char (point-min))
  179.       ;; If there is an EOOH header, then we have to remove some
  180.       ;; duplicated headers.
  181.       (setq summary-line (looking-at "Summary-line:"))
  182.       (when (search-forward "\n*** EOOH ***" nil t)
  183.         (if summary-line
  184.         ;; The headers to be deleted are located before the
  185.         ;; EOOH line...
  186.         (delete-region (point-min) (progn (forward-line 1)
  187.                           (point)))
  188.           ;; ...or after.
  189.           (delete-region (progn (beginning-of-line) (point))
  190.                  (or (search-forward "\n\n" nil t)
  191.                  (point)))))
  192.       (if (numberp article)
  193.           (cons nnbabyl-current-group article)
  194.         (nnbabyl-article-group-number)))))))
  195.  
  196. (deffoo nnbabyl-request-group (group &optional server dont-check)
  197.   (let ((active (cadr (assoc group nnbabyl-group-alist))))
  198.     (save-excursion
  199.       (cond
  200.        ((or (null active)
  201.         (null (nnbabyl-possibly-change-newsgroup group server)))
  202.     (nnheader-report 'nnbabyl "No such group: %s" group))
  203.        (dont-check
  204.     (nnheader-report 'nnbabyl "Selected group %s" group)
  205.     (nnheader-insert ""))
  206.        (t
  207.     (nnheader-report 'nnbabyl "Selected group %s" group)
  208.     (nnheader-insert "211 %d %d %d %s\n"
  209.              (1+ (- (cdr active) (car active)))
  210.              (car active) (cdr active) group))))))
  211.  
  212. (deffoo nnbabyl-request-scan (&optional group server)
  213.   (nnbabyl-possibly-change-newsgroup group server)
  214.   (nnbabyl-read-mbox)
  215.   (nnmail-get-new-mail
  216.    'nnbabyl
  217.    (lambda ()
  218.      (save-excursion
  219.        (set-buffer nnbabyl-mbox-buffer)
  220.        (save-buffer)))
  221.    (file-name-directory nnbabyl-mbox-file)
  222.    group
  223.    (lambda ()
  224.      (save-excursion
  225.        (let ((in-buf (current-buffer)))
  226.      (goto-char (point-min))
  227.      (while (search-forward "\n\^_\n" nil t)
  228.        (delete-char -1))
  229.      (set-buffer nnbabyl-mbox-buffer)
  230.      (goto-char (point-max))
  231.      (search-backward "\n\^_" nil t)
  232.      (goto-char (match-end 0))
  233.      (insert-buffer-substring in-buf)))
  234.      (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))))
  235.  
  236. (deffoo nnbabyl-close-group (group &optional server)
  237.   t)
  238.  
  239. (deffoo nnbabyl-request-create-group (group &optional server args)
  240.   (nnmail-activate 'nnbabyl)
  241.   (unless (assoc group nnbabyl-group-alist)
  242.     (push (list group (cons 1 0))
  243.                     nnbabyl-group-alist)
  244.     (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))
  245.   t)
  246.  
  247. (deffoo nnbabyl-request-list (&optional server)
  248.   (save-excursion
  249.     (nnmail-find-file nnbabyl-active-file)
  250.     (setq nnbabyl-group-alist (nnmail-get-active))
  251.     t))
  252.  
  253. (deffoo nnbabyl-request-newgroups (date &optional server)
  254.   (nnbabyl-request-list server))
  255.  
  256. (deffoo nnbabyl-request-list-newsgroups (&optional server)
  257.   (nnheader-report 'nnbabyl "nnbabyl: LIST NEWSGROUPS is not implemented."))
  258.  
  259. (deffoo nnbabyl-request-expire-articles
  260.   (articles newsgroup &optional server force)
  261.   (nnbabyl-possibly-change-newsgroup newsgroup server)
  262.   (let* ((is-old t)
  263.      rest)
  264.     (nnmail-activate 'nnbabyl)
  265.  
  266.     (save-excursion
  267.       (set-buffer nnbabyl-mbox-buffer)
  268.       (gnus-set-text-properties (point-min) (point-max) nil)
  269.       (while (and articles is-old)
  270.     (goto-char (point-min))
  271.     (when (search-forward (nnbabyl-article-string (car articles)) nil t)
  272.       (if (setq is-old
  273.             (nnmail-expired-article-p
  274.              newsgroup
  275.              (buffer-substring
  276.               (point) (progn (end-of-line) (point))) force))
  277.           (progn
  278.         (nnheader-message 5 "Deleting article %d in %s..."
  279.                   (car articles) newsgroup)
  280.         (nnbabyl-delete-mail))
  281.         (push (car articles) rest)))
  282.     (setq articles (cdr articles)))
  283.       (save-buffer)
  284.       ;; Find the lowest active article in this group.
  285.       (let ((active (nth 1 (assoc newsgroup nnbabyl-group-alist))))
  286.     (goto-char (point-min))
  287.     (while (and (not (search-forward
  288.               (nnbabyl-article-string (car active)) nil t))
  289.             (<= (car active) (cdr active)))
  290.       (setcar active (1+ (car active)))
  291.       (goto-char (point-min))))
  292.       (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
  293.       (nconc rest articles))))
  294.  
  295. (deffoo nnbabyl-request-move-article
  296.   (article group server accept-form &optional last)
  297.   (let ((buf (get-buffer-create " *nnbabyl move*"))
  298.     result)
  299.     (and
  300.      (nnbabyl-request-article article group server)
  301.      (save-excursion
  302.        (set-buffer buf)
  303.        (insert-buffer-substring nntp-server-buffer)
  304.        (goto-char (point-min))
  305.        (while (re-search-forward
  306.            "^X-Gnus-Newsgroup:"
  307.            (save-excursion (search-forward "\n\n" nil t) (point)) t)
  308.      (delete-region (progn (beginning-of-line) (point))
  309.             (progn (forward-line 1) (point))))
  310.        (setq result (eval accept-form))
  311.        (kill-buffer (current-buffer))
  312.        result)
  313.      (save-excursion
  314.        (nnbabyl-possibly-change-newsgroup group server)
  315.        (set-buffer nnbabyl-mbox-buffer)
  316.        (goto-char (point-min))
  317.        (if (search-forward (nnbabyl-article-string article) nil t)
  318.        (nnbabyl-delete-mail))
  319.        (and last (save-buffer))))
  320.     result))
  321.  
  322. (deffoo nnbabyl-request-accept-article (group &optional server last)
  323.   (nnbabyl-possibly-change-newsgroup group server)
  324.   (nnmail-check-syntax)
  325.   (let ((buf (current-buffer))
  326.     result beg)
  327.     (and
  328.      (nnmail-activate 'nnbabyl)
  329.      (save-excursion
  330.        (goto-char (point-min))
  331.        (search-forward "\n\n" nil t)
  332.        (forward-line -1)
  333.        (save-excursion
  334.      (while (re-search-backward "^X-Gnus-Newsgroup: " beg t)
  335.        (delete-region (point) (progn (forward-line 1) (point)))))
  336.        (when nnmail-cache-accepted-message-ids
  337.      (nnmail-cache-insert (nnmail-fetch-field "message-id")))
  338.        (setq result
  339.          (if (stringp group)
  340.          (list (cons group (nnbabyl-active-number group)))
  341.            (nnmail-article-group 'nnbabyl-active-number)))
  342.        (if (and (null result)
  343.         (yes-or-no-p "Moved to `junk' group; delete article? "))
  344.        (setq result 'junk)
  345.      (setq result (car (nnbabyl-save-mail result))))
  346.        (set-buffer nnbabyl-mbox-buffer)
  347.        (goto-char (point-max))
  348.        (search-backward "\n\^_")
  349.        (goto-char (match-end 0))
  350.        (insert-buffer-substring buf)
  351.        (when last
  352.      (when nnmail-cache-accepted-message-ids
  353.        (nnmail-cache-insert (nnmail-fetch-field "message-id")))
  354.      (save-buffer)
  355.      (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file))
  356.        result))))
  357.  
  358. (deffoo nnbabyl-request-replace-article (article group buffer)
  359.   (nnbabyl-possibly-change-newsgroup group)
  360.   (save-excursion
  361.     (set-buffer nnbabyl-mbox-buffer)
  362.     (goto-char (point-min))
  363.     (if (not (search-forward (nnbabyl-article-string article) nil t))
  364.     nil
  365.       (nnbabyl-delete-mail t t)
  366.       (insert-buffer-substring buffer)
  367.       (save-buffer)
  368.       t)))
  369.  
  370. (deffoo nnbabyl-request-delete-group (group &optional force server)
  371.   (nnbabyl-possibly-change-newsgroup group server)
  372.   ;; Delete all articles in GROUP.
  373.   (if (not force)
  374.       ()                ; Don't delete the articles.
  375.     (save-excursion
  376.       (set-buffer nnbabyl-mbox-buffer)
  377.       (goto-char (point-min))
  378.       ;; Delete all articles in this group.
  379.       (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"))
  380.         found)
  381.     (while (search-forward ident nil t)
  382.       (setq found t)
  383.       (nnbabyl-delete-mail))
  384.     (when found
  385.       (save-buffer)))))
  386.   ;; Remove the group from all structures.
  387.   (setq nnbabyl-group-alist
  388.     (delq (assoc group nnbabyl-group-alist) nnbabyl-group-alist)
  389.     nnbabyl-current-group nil)
  390.   ;; Save the active file.
  391.   (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
  392.   t)
  393.  
  394. (deffoo nnbabyl-request-rename-group (group new-name &optional server)
  395.   (nnbabyl-possibly-change-newsgroup group server)
  396.   (save-excursion
  397.     (set-buffer nnbabyl-mbox-buffer)
  398.     (goto-char (point-min))
  399.     (let ((ident (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"))
  400.       (new-ident (concat "\nX-Gnus-Newsgroup: " new-name ":"))
  401.       found)
  402.       (while (search-forward ident nil t)
  403.     (replace-match new-ident t t)
  404.     (setq found t))
  405.       (when found
  406.     (save-buffer))))
  407.   (let ((entry (assoc group nnbabyl-group-alist)))
  408.     (and entry (setcar entry new-name))
  409.     (setq nnbabyl-current-group nil)
  410.     ;; Save the new group alist.
  411.     (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
  412.     t))
  413.  
  414.  
  415. ;;; Internal functions.
  416.  
  417. ;; If FORCE, delete article no matter how many X-Gnus-Newsgroup
  418. ;; headers there are.  If LEAVE-DELIM, don't delete the Unix mbox
  419. ;; delimiter line.
  420. (defun nnbabyl-delete-mail (&optional force leave-delim)
  421.   ;; Delete the current X-Gnus-Newsgroup line.
  422.   (unless force
  423.     (delete-region
  424.      (progn (beginning-of-line) (point))
  425.      (progn (forward-line 1) (point))))
  426.   ;; Beginning of the article.
  427.   (save-excursion
  428.     (save-restriction
  429.       (widen)
  430.       (narrow-to-region
  431.        (save-excursion
  432.     (unless (re-search-backward (concat "^" nnbabyl-mail-delimiter) nil t)
  433.       (goto-char (point-min))
  434.       (end-of-line))
  435.      (if leave-delim (progn (forward-line 1) (point))
  436.        (match-beginning 0)))
  437.        (progn
  438.      (forward-line 1)
  439.      (or (and (re-search-forward (concat "^" nnbabyl-mail-delimiter)
  440.                      nil t)
  441.           (match-beginning 0))
  442.          (point-max))))
  443.       (goto-char (point-min))
  444.       ;; Only delete the article if no other groups owns it as well.
  445.       (when (or force (not (re-search-forward "^X-Gnus-Newsgroup: " nil t)))
  446.     (delete-region (point-min) (point-max))))))
  447.  
  448. (defun nnbabyl-possibly-change-newsgroup (newsgroup &optional server)
  449.   (when (and server
  450.          (not (nnbabyl-server-opened server)))
  451.     (nnbabyl-open-server server))
  452.   (when (or (not nnbabyl-mbox-buffer)
  453.         (not (buffer-name nnbabyl-mbox-buffer)))
  454.     (save-excursion (nnbabyl-read-mbox)))
  455.   (unless nnbabyl-group-alist
  456.     (nnmail-activate 'nnbabyl))
  457.   (if newsgroup
  458.       (if (assoc newsgroup nnbabyl-group-alist)
  459.       (setq nnbabyl-current-group newsgroup)
  460.     (nnheader-report 'nnbabyl "No such group in file"))
  461.     t))
  462.  
  463. (defun nnbabyl-article-string (article)
  464.   (if (numberp article)
  465.       (concat "\nX-Gnus-Newsgroup: " nnbabyl-current-group ":"
  466.           (int-to-string article) " ")
  467.     (concat "\nMessage-ID: " article)))
  468.  
  469. (defun nnbabyl-article-group-number ()
  470.   (save-excursion
  471.     (goto-char (point-min))
  472.     (when (re-search-forward "^X-Gnus-Newsgroup: +\\([^:]+\\):\\([0-9]+\\) "
  473.                  nil t)
  474.       (cons (buffer-substring (match-beginning 1) (match-end 1))
  475.         (string-to-int
  476.          (buffer-substring (match-beginning 2) (match-end 2)))))))
  477.  
  478. (defun nnbabyl-insert-lines ()
  479.   "Insert how many lines and chars there are in the body of the mail."
  480.   (let (lines chars)
  481.     (save-excursion
  482.       (goto-char (point-min))
  483.       (when (search-forward "\n\n" nil t)
  484.     ;; There may be an EOOH line here...
  485.     (when (looking-at "\\*\\*\\* EOOH \\*\\*\\*")
  486.       (search-forward "\n\n" nil t))
  487.     (setq chars (- (point-max) (point))
  488.           lines (max (- (count-lines (point) (point-max)) 1) 0))
  489.     ;; Move back to the end of the headers.
  490.     (goto-char (point-min))
  491.     (search-forward "\n\n" nil t)
  492.     (forward-char -1)
  493.     (save-excursion
  494.       (when (re-search-backward "^Lines: " nil t)
  495.         (delete-region (point) (progn (forward-line 1) (point)))))
  496.     (insert (format "Lines: %d\n" lines))
  497.     chars))))
  498.  
  499. (defun nnbabyl-save-mail (group-art)
  500.   ;; Called narrowed to an article.
  501.   (nnbabyl-insert-lines)
  502.   (nnmail-insert-xref group-art)
  503.   (nnbabyl-insert-newsgroup-line group-art)
  504.   (run-hooks 'nnbabyl-prepare-save-mail-hook)
  505.   group-art)
  506.  
  507. (defun nnbabyl-insert-newsgroup-line (group-art)
  508.   (save-excursion
  509.     (goto-char (point-min))
  510.     (while (looking-at "From ")
  511.       (replace-match "Mail-from: From " t t)
  512.       (forward-line 1))
  513.     ;; If there is a C-l at the beginning of the narrowed region, this
  514.     ;; isn't really a "save", but rather a "scan".
  515.     (goto-char (point-min))
  516.     (unless (looking-at "\^L")
  517.       (save-excursion
  518.     (insert "\^L\n0, unseen,,\n*** EOOH ***\n")
  519.     (goto-char (point-max))
  520.     (insert "\^_\n")))
  521.     (when (search-forward "\n\n" nil t)
  522.       (forward-char -1)
  523.       (while group-art
  524.     (insert (format "X-Gnus-Newsgroup: %s:%d   %s\n"
  525.             (caar group-art) (cdar group-art)
  526.             (current-time-string)))
  527.     (setq group-art (cdr group-art))))
  528.     t))
  529.  
  530. (defun nnbabyl-active-number (group)
  531.   ;; Find the next article number in GROUP.
  532.   (let ((active (cadr (assoc group nnbabyl-group-alist))))
  533.     (if active
  534.     (setcdr active (1+ (cdr active)))
  535.       ;; This group is new, so we create a new entry for it.
  536.       ;; This might be a bit naughty... creating groups on the drop of
  537.       ;; a hat, but I don't know...
  538.       (push (list group (setq active (cons 1 1)))
  539.         nnbabyl-group-alist))
  540.     (cdr active)))
  541.  
  542. (defun nnbabyl-create-mbox ()
  543.   (unless (file-exists-p nnbabyl-mbox-file)
  544.     ;; Create a new, empty RMAIL mbox file.
  545.     (save-excursion
  546.       (set-buffer (setq nnbabyl-mbox-buffer
  547.             (create-file-buffer nnbabyl-mbox-file)))
  548.       (setq buffer-file-name nnbabyl-mbox-file)
  549.       (insert "BABYL OPTIONS:\n\n\^_")
  550.       (nnmail-write-region
  551.        (point-min) (point-max) nnbabyl-mbox-file t 'nomesg))))
  552.  
  553. (defun nnbabyl-read-mbox ()
  554.   (nnmail-activate 'nnbabyl)
  555.   (nnbabyl-create-mbox)
  556.  
  557.   (unless (and nnbabyl-mbox-buffer
  558.        (buffer-name nnbabyl-mbox-buffer)
  559.        (save-excursion
  560.          (set-buffer nnbabyl-mbox-buffer)
  561.          (= (buffer-size) (nnheader-file-size nnbabyl-mbox-file))))
  562.     ;; This buffer has changed since we read it last.  Possibly.
  563.     (save-excursion
  564.       (let ((delim (concat "^" nnbabyl-mail-delimiter))
  565.         (alist nnbabyl-group-alist)
  566.         start end number)
  567.     (set-buffer (setq nnbabyl-mbox-buffer
  568.               (nnheader-find-file-noselect
  569.                nnbabyl-mbox-file nil 'raw)))
  570.     ;; Save previous buffer mode.
  571.     (setq nnbabyl-previous-buffer-mode
  572.           (cons (cons (point-min) (point-max))
  573.             major-mode))
  574.  
  575.     (buffer-disable-undo (current-buffer))
  576.     (widen)
  577.     (setq buffer-read-only nil)
  578.     (fundamental-mode)
  579.  
  580.     ;; Go through the group alist and compare against
  581.     ;; the rmail file.
  582.     (while alist
  583.       (goto-char (point-max))
  584.       (when (and (re-search-backward
  585.               (format "^X-Gnus-Newsgroup: %s:\\([0-9]+\\) "
  586.                   (caar alist))
  587.               nil t)
  588.              (> (setq number
  589.                   (string-to-number
  590.                    (buffer-substring
  591.                 (match-beginning 1) (match-end 1))))
  592.             (cdadar alist)))
  593.         (setcdr (cadar alist) number))
  594.       (setq alist (cdr alist)))
  595.  
  596.     ;; We go through the mbox and make sure that each and
  597.     ;; every mail belongs to some group or other.
  598.     (goto-char (point-min))
  599.     (if (looking-at "\^L")
  600.         (setq start (point))
  601.       (re-search-forward delim nil t)
  602.       (setq start (match-end 0)))
  603.     (while (re-search-forward delim nil t)
  604.       (setq end (match-end 0))
  605.       (unless (search-backward "\nX-Gnus-Newsgroup: " start t)
  606.         (goto-char end)
  607.         (save-excursion
  608.           (save-restriction
  609.         (narrow-to-region (goto-char start) end)
  610.         (nnbabyl-save-mail
  611.          (nnmail-article-group 'nnbabyl-active-number))
  612.         (setq end (point-max)))))
  613.       (goto-char (setq start end)))
  614.     (when (buffer-modified-p (current-buffer))
  615.       (save-buffer))
  616.     (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)))))
  617.  
  618. (defun nnbabyl-remove-incoming-delims ()
  619.   (goto-char (point-min))
  620.   (while (search-forward "\^_" nil t)
  621.     (replace-match "?" t t)))
  622.  
  623. (defun nnbabyl-check-mbox ()
  624.   "Go through the nnbabyl mbox and make sure that no article numbers are reused."
  625.   (interactive)
  626.   (let ((idents (make-vector 1000 0))
  627.     id)
  628.     (save-excursion
  629.       (when (or (not nnbabyl-mbox-buffer)
  630.         (not (buffer-name nnbabyl-mbox-buffer)))
  631.     (nnbabyl-read-mbox))
  632.       (set-buffer nnbabyl-mbox-buffer)
  633.       (goto-char (point-min))
  634.       (while (re-search-forward "^X-Gnus-Newsgroup: \\([^ ]+\\) "  nil t)
  635.     (if (intern-soft (setq id (match-string 1)) idents)
  636.         (progn
  637.           (delete-region (progn (beginning-of-line) (point))
  638.                  (progn (forward-line 1) (point)))
  639.           (nnheader-message 7 "Moving %s..." id)
  640.           (nnbabyl-save-mail
  641.            (nnmail-article-group 'nnbabyl-active-number)))
  642.       (intern id idents)))
  643.       (when (buffer-modified-p (current-buffer))
  644.     (save-buffer))
  645.       (nnmail-save-active nnbabyl-group-alist nnbabyl-active-file)
  646.       (message ""))))
  647.  
  648. (provide 'nnbabyl)
  649.  
  650. ;;; nnbabyl.el ends here
  651.